diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index c2902ee7d..87c3d0be8 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -373,7 +373,7 @@ let transl_toplevel_item = function
       Lprim(Psetglobal id, [transl_path path])
   | Tstr_module(id, modl) ->
       Ident.make_global id;
-      Lprim(Psetglobal id, [transl_module Tcoerce_none None modl])
+      Lprim(Psetglobal id, [transl_module Tcoerce_none (Some(Pident id)) modl])
   | Tstr_modtype(id, decl) ->
       lambda_unit
   | Tstr_open path ->
diff --git a/debugger/printval.ml b/debugger/printval.ml
index cb8117a42..48eaef1d2 100644
--- a/debugger/printval.ml
+++ b/debugger/printval.ml
@@ -48,7 +48,27 @@ let check_depth ppf depth obj ty =
     false
   end else true
 
-module Printer = Genprintval.Make(Debugcom.Remote_value)
+module EvalPath =
+  struct
+    type value = Debugcom.Remote_value.t
+    exception Error
+    let rec eval_path = function
+      Pident id ->
+        begin try
+          Debugcom.Remote_value.global (Symtable.get_global_position id)
+        with Symtable.Error _ ->
+          raise Error
+        end
+    | Pdot(root, fieldname, pos) ->
+        let v = eval_path root in
+        if not (Debugcom.Remote_value.is_block v)
+        then raise Error
+        else Debugcom.Remote_value.field v pos
+    | Papply(p1, p2) ->
+        raise Error
+  end
+
+module Printer = Genprintval.Make(Debugcom.Remote_value)(EvalPath)
 
 let install_printer path ty ppf fn =
   Printer.install_printer path ty
@@ -64,7 +84,7 @@ let remove_printer = Printer.remove_printer
 let max_printer_depth = ref 20
 let max_printer_steps = ref 300
 
-let print_exception = Printer.print_exception
+let print_exception = Printer.print_untyped_exception
 
 let print_value max_depth env obj (ppf : Format.formatter) ty =
   Printer.print_value !max_printer_steps max_depth
diff --git a/parsing/longident.ml b/parsing/longident.ml
index 1b27a561e..57652ea1a 100644
--- a/parsing/longident.ml
+++ b/parsing/longident.ml
@@ -23,3 +23,16 @@ let rec flat accu = function
   | Lapply(l1, l2) -> Misc.fatal_error "Longident.flat"
 
 let flatten lid = flat [] lid
+
+let rec split_at_dots s pos =
+  try
+    let dot = String.index_from s pos '.' in
+    String.sub s pos (dot - pos) :: split_at_dots s (dot + 1)
+  with Not_found ->
+    [String.sub s pos (String.length s - pos)]
+
+let parse s =
+  match split_at_dots s 0 with
+    [] -> Lident ""  (* should not happen, but don't put assert false
+                        so as not to crash the toplevel (see Genprintval) *)
+  | hd :: tl -> List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl
diff --git a/parsing/longident.mli b/parsing/longident.mli
index 11432b8a1..7b4e943bf 100644
--- a/parsing/longident.mli
+++ b/parsing/longident.mli
@@ -20,3 +20,4 @@ type t =
   | Lapply of t * t
 
 val flatten: t -> string list
+val parse: string -> t
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index ace6bb32a..7d43d0b47 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -23,7 +23,6 @@ open Types
 module type OBJ =
   sig
     type t
-
     val obj : t -> 'a
     val is_block : t -> bool
     val tag : t -> int
@@ -31,20 +30,25 @@ module type OBJ =
     val field : t -> int -> t
   end
 
+module type EVALPATH =
+  sig
+    type value
+    val eval_path: Path.t -> value
+    exception Error
+  end
+
 module type S =
   sig
     type t
-
     val install_printer : Path.t -> Types.type_expr -> (t -> unit) -> unit
     val remove_printer : Path.t -> unit
-
-    val print_exception : formatter -> t -> unit
+    val print_untyped_exception : formatter -> t -> unit
     val print_value :
           int -> int -> (int -> t -> Types.type_expr -> bool) ->
           Env.t -> t -> formatter -> type_expr -> unit
   end
 
-module Make(O : OBJ) = struct
+module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
 
     type t = O.t
 
@@ -53,14 +57,15 @@ module Make(O : OBJ) = struct
        Here, we do a feeble attempt to print
        integer, string and float arguments... *)
 
-    let print_exception_args obj ppf start_offset =
+    let print_untyped_exception_args obj ppf start_offset =
       if O.size obj > start_offset then begin
         fprintf ppf "@[<1>(";
         for i = start_offset to O.size obj - 1 do
           if i > start_offset then fprintf ppf ",@ ";
           let arg = O.field obj i in
           if not (O.is_block arg) then
-            fprintf ppf "%i" (O.obj arg : int) (* Note: this could be a char! *)
+            fprintf ppf "%i" (O.obj arg : int)
+               (* Note: this could be a char or a constant constructor... *)
           else if O.tag arg = Obj.string_tag then
             fprintf ppf "\"%s\"" (String.escaped (O.obj arg : string))
           else if O.tag arg = Obj.double_tag then
@@ -71,15 +76,15 @@ module Make(O : OBJ) = struct
         fprintf ppf ")@]"
       end
 
-    let print_path = Printtyp.path
-
-    let print_exception ppf bucket =
+    let print_untyped_exception ppf bucket =
       let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
       if (name = "Match_failure" || name = "Assert_failure")
       && O.size bucket = 2
       && O.tag(O.field bucket 1) = 0
-      then fprintf ppf "%s%a" name (print_exception_args (O.field bucket 1)) 0
-      else fprintf ppf "%s%a" name (print_exception_args bucket) 1
+      then fprintf ppf "%s%a" name
+                       (print_untyped_exception_args (O.field bucket 1)) 0
+      else fprintf ppf "%s%a" name
+                       (print_untyped_exception_args bucket) 1
 
     (* The user-defined printers. Also used for some builtin types. *)
 
@@ -185,15 +190,13 @@ module Make(O : OBJ) = struct
               if check_depth depth obj ty then begin
                 if prio > 0
                 then
-                  fprintf ppf "@[<1>(%a)@]" (print_val_list 1 depth obj) ty_list
-                else fprintf ppf "@[%a@]" (print_val_list 1 depth obj) ty_list
+                  fprintf ppf "@[<1>(%a)@]" 
+                          (print_val_list 1 0 depth obj) ty_list
+                else fprintf ppf "@[%a@]"
+                          (print_val_list 1 0 depth obj) ty_list
               end
           | Tconstr(path, [], _) when Path.same path Predef.path_exn ->
-              if check_depth depth obj ty then begin
-                if prio > 1
-                then fprintf ppf "@[<2>(%a)@]" print_exception obj
-                else fprintf ppf "@[<1>%a@]" print_exception obj
-              end
+              print_exception prio depth ppf obj
           | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list ->
               if O.is_block obj then begin
                 if check_depth depth obj ty then begin
@@ -243,26 +246,8 @@ module Make(O : OBJ) = struct
                            try Ctype.apply env decl.type_params ty ty_list with
                              Ctype.Cannot_apply -> abstract_type)
                         constr_args in
-                    begin match ty_args with
-                    | [] ->
-                        print_constr env path ppf constr_name
-                    | [ty1] ->
-                        if check_depth depth obj ty then
-                          (if prio > 1
-                          then fprintf ppf "@[<2>(%a@ %a)@]"
-                          else fprintf ppf "@[<1>%a@ %a@]")
-                          (print_constr env path) constr_name
-                          (cautious
-                             (print_val 2 (depth - 1) (O.field obj 0) ppf))
-                          ty1;
-                    | tyl ->
-                        if check_depth depth obj ty then
-                          (if prio > 1
-                          then fprintf ppf "@[<2>(%a@ @[<1>(%a)@])@]"
-                          else fprintf ppf "@[<1>%a@ @[<1>(%a)@]@]")
-                          (print_constr env path) constr_name
-                          (print_val_list 1 depth obj) tyl;
-                    end
+                    print_constr_with_args (print_constr env path) constr_name
+                                           prio 0 depth obj ppf ty_args
                 | {type_kind = Type_record(lbl_list, rep)} ->
                     if check_depth depth obj ty then begin
                       let rec print_fields pos ppf = function
@@ -322,14 +307,59 @@ module Make(O : OBJ) = struct
           | Tfield(_, _, _, _) | Tnil | Tlink _ ->
               fatal_error "Printval.print_value"
 
-      and print_val_list prio depth obj ppf ty_list =
+      and print_val_list prio start depth obj ppf ty_list =
         let rec print_list i = function
           |  [] -> ()
           | ty :: ty_list ->
-              if i > 0 then fprintf ppf ",@ ";
+              if i > start then fprintf ppf ",@ ";
               print_val prio (depth - 1) (O.field obj i) ppf ty;
               print_list (i + 1) ty_list in
-      cautious (print_list 0) ppf ty_list
+      cautious (print_list start) ppf ty_list
+
+      and print_constr_with_args
+             print_cstr cstr_name prio start depth obj ppf ty_args =
+        match ty_args with
+          [] ->
+            print_cstr ppf cstr_name
+        | [ty1] ->
+            if check_depth depth obj ty then
+              (if prio > 1
+              then fprintf ppf "@[<2>(%a@ %a)@]"
+              else fprintf ppf "@[<1>%a@ %a@]")
+              print_cstr cstr_name
+              (cautious
+                 (print_val 2 (depth - 1) (O.field obj start) ppf))
+              ty1;
+        | tyl ->
+            if check_depth depth obj ty then
+              (if prio > 1
+              then fprintf ppf "@[<2>(%a@ @[<1>(%a)@])@]"
+              else fprintf ppf "@[<1>%a@ @[<1>(%a)@]@]")
+              print_cstr cstr_name
+              (print_val_list 1 start depth obj) tyl;
+
+    and print_exception prio depth ppf bucket =
+      let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
+      let lid = Longident.parse name in
+      try
+        (* Attempt to recover the constructor description for the exn
+           from its name *)
+        let cstr = Env.lookup_constructor lid env in
+        let path =
+          match cstr.cstr_tag with
+            Cstr_exception p -> p | _ -> raise Not_found in
+        (* Make sure this is the right exception and not an homonym,
+           by evaluating the exception found and comparing with the identifier
+           contained in the exception bucket *)
+        if O.field bucket 0 != EVP.eval_path path then raise Not_found;
+        print_constr_with_args
+           pp_print_string name prio 1 depth bucket ppf cstr.cstr_args
+      with Not_found | EVP.Error ->
+        if check_depth depth obj ty then begin
+          if prio > 1
+          then fprintf ppf "@[<2>(%a)@]" print_untyped_exception obj
+          else fprintf ppf "@[<1>%a@]" print_untyped_exception obj
+        end
 
     in cautious (print_val 0 max_depth obj ppf) ppf ty
 
diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli
index 832d40cbc..78b55479c 100644
--- a/toplevel/genprintval.mli
+++ b/toplevel/genprintval.mli
@@ -20,7 +20,6 @@ open Format
 module type OBJ =
   sig
     type t
-
     val obj : t -> 'a
     val is_block : t -> bool
     val tag : t -> int
@@ -28,17 +27,23 @@ module type OBJ =
     val field : t -> int -> t
   end
 
+module type EVALPATH =
+  sig
+    type value
+    val eval_path: Path.t -> value
+    exception Error
+  end
+
 module type S =
   sig
     type t
-
     val install_printer : Path.t -> Types.type_expr -> (t -> unit) -> unit
     val remove_printer : Path.t -> unit
-
-    val print_exception : formatter -> t -> unit
+    val print_untyped_exception : formatter -> t -> unit
     val print_value :
           int -> int -> (int -> t -> Types.type_expr -> bool) ->
           Env.t -> t -> formatter -> type_expr -> unit
   end
 
-module Make(O : OBJ) : (S with type t = O.t)
+module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) :
+         (S with type t = O.t)
diff --git a/toplevel/printval.ml b/toplevel/printval.ml
index d86e536ba..5c8c01c8e 100644
--- a/toplevel/printval.ml
+++ b/toplevel/printval.ml
@@ -12,14 +12,30 @@
 
 (* $Id$ *)
 
+open Misc
+open Path
+
+(* Return the value referred to by a path *)
+
+let rec eval_path = function
+  | Pident id -> Symtable.get_global_value id
+  | Pdot(p, s, pos) -> Obj.field (eval_path p) pos
+  | Papply(p1, p2) -> fatal_error "Topdirs.eval_path"
+
 (* To print values *)
 
-module Printer = Genprintval.Make(Obj)
+module EvalPath = struct
+  type value = Obj.t
+  exception Error
+  let eval_path p = try eval_path p with Symtable.Error _ -> raise Error
+end
+
+module Printer = Genprintval.Make(Obj)(EvalPath)
 
 let max_printer_depth = ref 100
 let max_printer_steps = ref 300
 
-let print_exception = Printer.print_exception
+let print_untyped_exception = Printer.print_untyped_exception
 let print_value env obj ty =
   Printer.print_value !max_printer_steps !max_printer_depth
     (fun _ _ _ -> true) env obj ty
diff --git a/toplevel/printval.mli b/toplevel/printval.mli
index c8302df0a..cb26a9f11 100644
--- a/toplevel/printval.mli
+++ b/toplevel/printval.mli
@@ -17,8 +17,10 @@
 open Types
 open Format
 
-val print_exception: formatter -> Obj.t -> unit
+val eval_path: Path.t -> Obj.t
+
 val print_value: Env.t -> Obj.t -> formatter -> type_expr -> unit
+val print_untyped_exception: formatter -> Obj.t -> unit
 
 val install_printer : Path.t -> Types.type_expr -> (Obj.t -> unit) -> unit
 val remove_printer : Path.t -> unit
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index 9f6127837..4019a08a1 100644
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -27,13 +27,6 @@ open Toploop
 (* The standard error formatter *)
 let std_err = err_formatter
 
-(* Return the value referred to by a path *)
-
-let rec eval_path = function
-  | Pident id -> Symtable.get_global_value id
-  | Pdot(p, s, pos) -> Obj.field (eval_path p) pos
-  | Papply(p1, p2) -> fatal_error "Topdirs.eval_path"
-
 (* To quit *)
 
 let dir_quit () = exit 0
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index 020f8db2d..b063bf679 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -115,6 +115,10 @@ let rec pr_items space env ppf = function
 
 let print_items = pr_items false
 
+(* The current typing environment for the toplevel *)
+
+let toplevel_env = ref Env.empty
+
 (* Print an exception produced by an evaluation *)
 
 let print_exception_outcome ppf = function
@@ -127,7 +131,7 @@ let print_exception_outcome ppf = function
       fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
   | exn ->
       fprintf ppf "@[Uncaught exception: %a.@."
-      print_exception (Obj.repr exn)
+              (print_value !toplevel_env (Obj.repr exn)) Predef.type_exn
 
 (* The table of toplevel directives. 
    Filled by functions from module topdirs. *)
@@ -136,8 +140,6 @@ let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t)
 
 (* Execute a toplevel phrase *)
 
-let toplevel_env = ref Env.empty
-
 let execute_phrase print_outcome ppf phr =
   match phr with
   | Ptop_def sstr ->
diff --git a/toplevel/trace.ml b/toplevel/trace.ml
index e76d3e169..f74586fb7 100644
--- a/toplevel/trace.ml
+++ b/toplevel/trace.ml
@@ -82,8 +82,8 @@ let rec instrument_result env name ppf clos_typ =
             trace_res res
           with exn ->
             fprintf ppf "@[<2>%a raises@ %a@]@."
-            Printtyp.longident starred_name
-            print_exception (Obj.repr exn);
+              Printtyp.longident starred_name
+              (print_value !toplevel_env (Obj.repr exn)) Predef.type_exn;
             raise exn))
   | _ -> (fun v -> v)
 
@@ -106,8 +106,8 @@ let instrument_closure env name ppf clos_typ =
           trace_res res
         with exn ->
           fprintf ppf "@[<2>%a raises@ %a@]@."
-          Printtyp.longident name
-          print_exception (Obj.repr exn);
+            Printtyp.longident name
+            (print_value !toplevel_env (Obj.repr exn)) Predef.type_exn;
           raise exn)
   | _ -> assert false