make world until labltk browser.

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/dothat@9489 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

6 files changed, 248 insertions, 181 deletions

diff --git a/.depend b/.depend
index 0d45cfcf77..58b9a646b5 100644
--- a/.depend
+++ b/.depend
@@ -89,8 +89,8 @@ typing/parmatch.cmi: typing/types.cmi typing/typedtree.cmi \
 typing/path.cmi: typing/ident.cmi 
 typing/predef.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi 
 typing/primitive.cmi: 
-typing/printtyp.cmi: typing/types.cmi typing/path.cmi typing/outcometree.cmi \
-    parsing/longident.cmi typing/ident.cmi 
+typing/printtyp.cmi: typing/types.cmi parsing/reftypes.cmi typing/path.cmi \
+    typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi 
 typing/stypes.cmi: typing/typedtree.cmi parsing/location.cmi typing/annot.cmi 
 typing/subst.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi 
 typing/typeclass.cmi: typing/types.cmi typing/typedtree.cmi \
@@ -376,16 +376,16 @@ bytecomp/lambda.cmx: typing/types.cmx typing/primitive.cmx typing/path.cmx \
     parsing/asttypes.cmi bytecomp/lambda.cmi 
 bytecomp/matching.cmo: typing/types.cmi bytecomp/typeopt.cmi \
     typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \
-    typing/primitive.cmi typing/predef.cmi typing/parmatch.cmi utils/misc.cmi \
+    typing/primitive.cmi typing/parmatch.cmi utils/misc.cmi \
     parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
-    utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
-    bytecomp/matching.cmi 
+    utils/clflags.cmi typing/builtin.cmi typing/btype.cmi \
+    parsing/asttypes.cmi bytecomp/matching.cmi 
 bytecomp/matching.cmx: typing/types.cmx bytecomp/typeopt.cmx \
     typing/typedtree.cmx bytecomp/switch.cmx bytecomp/printlambda.cmx \
-    typing/primitive.cmx typing/predef.cmx typing/parmatch.cmx utils/misc.cmx \
+    typing/primitive.cmx typing/parmatch.cmx utils/misc.cmx \
     parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
-    utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
-    bytecomp/matching.cmi 
+    utils/clflags.cmx typing/builtin.cmx typing/btype.cmx \
+    parsing/asttypes.cmi bytecomp/matching.cmi 
 bytecomp/meta.cmo: bytecomp/meta.cmi 
 bytecomp/meta.cmx: bytecomp/meta.cmi 
 bytecomp/opcodes.cmo: 
@@ -408,16 +408,14 @@ bytecomp/simplif.cmx: bytecomp/lambda.cmx typing/ident.cmx utils/clflags.cmx \
     parsing/asttypes.cmi bytecomp/simplif.cmi 
 bytecomp/switch.cmo: bytecomp/switch.cmi 
 bytecomp/switch.cmx: bytecomp/switch.cmi 
-bytecomp/symtable.cmo: utils/tbl.cmi bytecomp/runtimedef.cmi \
-    typing/predef.cmi utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \
-    typing/ident.cmi bytecomp/dll.cmi bytecomp/cmo_format.cmi \
-    utils/clflags.cmi bytecomp/bytesections.cmi parsing/asttypes.cmi \
-    bytecomp/symtable.cmi 
-bytecomp/symtable.cmx: utils/tbl.cmx bytecomp/runtimedef.cmx \
-    typing/predef.cmx utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \
-    typing/ident.cmx bytecomp/dll.cmx bytecomp/cmo_format.cmi \
-    utils/clflags.cmx bytecomp/bytesections.cmx parsing/asttypes.cmi \
-    bytecomp/symtable.cmi 
+bytecomp/symtable.cmo: utils/tbl.cmi bytecomp/runtimedef.cmi utils/misc.cmi \
+    bytecomp/meta.cmi bytecomp/lambda.cmi typing/ident.cmi bytecomp/dll.cmi \
+    bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytesections.cmi \
+    typing/builtin.cmi parsing/asttypes.cmi bytecomp/symtable.cmi 
+bytecomp/symtable.cmx: utils/tbl.cmx bytecomp/runtimedef.cmx utils/misc.cmx \
+    bytecomp/meta.cmx bytecomp/lambda.cmx typing/ident.cmx bytecomp/dll.cmx \
+    bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytesections.cmx \
+    typing/builtin.cmx parsing/asttypes.cmi bytecomp/symtable.cmi 
 bytecomp/translclass.cmo: typing/types.cmi bytecomp/typeopt.cmi \
     typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \
     typing/path.cmi utils/misc.cmi bytecomp/matching.cmi parsing/location.cmi \
@@ -433,13 +431,15 @@ bytecomp/translcore.cmo: typing/types.cmi bytecomp/typeopt.cmi \
     typing/predef.cmi typing/path.cmi typing/parmatch.cmi utils/misc.cmi \
     bytecomp/matching.cmi parsing/location.cmi bytecomp/lambda.cmi \
     typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \
-    typing/btype.cmi parsing/asttypes.cmi bytecomp/translcore.cmi 
+    typing/builtin.cmi typing/btype.cmi parsing/asttypes.cmi \
+    bytecomp/translcore.cmi 
 bytecomp/translcore.cmx: typing/types.cmx bytecomp/typeopt.cmx \
     typing/typedtree.cmx bytecomp/translobj.cmx typing/primitive.cmx \
     typing/predef.cmx typing/path.cmx typing/parmatch.cmx utils/misc.cmx \
     bytecomp/matching.cmx parsing/location.cmx bytecomp/lambda.cmx \
     typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \
-    typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi 
+    typing/builtin.cmx typing/btype.cmx parsing/asttypes.cmi \
+    bytecomp/translcore.cmi 
 bytecomp/translmod.cmo: typing/types.cmi typing/typedtree.cmi \
     bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \
     typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
diff --git a/boot/ocamlc b/boot/ocamlc
index cad835a102..e817c53267 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile
index 97b5bd2464..31ba514d33 100644
--- a/otherlibs/dynlink/Makefile
+++ b/otherlibs/dynlink/Makefile
@@ -32,8 +32,9 @@ COMPILEROBJS=\
   ../../parsing/location.cmo ../../parsing/longident.cmo \
   ../../typing/ident.cmo ../../typing/path.cmo \
   ../../typing/primitive.cmo ../../typing/types.cmo \
-  ../../typing/btype.cmo ../../typing/subst.cmo ../../typing/predef.cmo \
-  ../../typing/datarepr.cmo ../../typing/env.cmo \
+  ../../typing/btype.cmo ../../typing/subst.cmo \
+  ../../typing/predef.cmo ../../typing/datarepr.cmo \
+  ../../typing/builtin.cmo ../../typing/env.cmo \
   ../../bytecomp/lambda.cmo ../../bytecomp/instruct.cmo \
   ../../bytecomp/cmo_format.cmi ../../bytecomp/opcodes.cmo \
   ../../bytecomp/runtimedef.cmo ../../bytecomp/bytesections.cmo \
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 3277004006..bc99ed6839 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -61,6 +61,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
        Here, we do a feeble attempt to print
        integer, string and float arguments... *)
     let outval_of_untyped_exception_args obj start_offset =
+      let underscore = Oval_constr (Oconstr (Oide_ident "_"), []) in
       if O.size obj > start_offset then begin
         let list = ref [] in
         for i = start_offset to O.size obj - 1 do
@@ -74,7 +75,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
           else if O.tag arg = Obj.double_tag then
             list := Oval_float (O.obj arg : float) :: !list
           else
-            list := Oval_constr (Oide_ident "_", []) :: !list
+            list := underscore :: !list
         done;
         List.rev !list
       end
@@ -90,7 +91,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
         && O.tag(O.field bucket 1) = 0
         then outval_of_untyped_exception_args (O.field bucket 1) 0
         else outval_of_untyped_exception_args bucket 1 in
-      Oval_constr (Oide_ident name, args)
+      Oval_constr (Oconstr (Oide_ident name), args)
 
     (* The user-defined printers. Also used for some builtin types. *)
 
@@ -115,7 +116,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
       let print_val ppf obj =
         try fn ppf obj with
         | exn ->
-           fprintf ppf "<printer %a raised an exception>" Printtyp.path path in
+           fprintf ppf "<printer %a raised an exception>"
+             Printtyp.path path in
       let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in
       printers := (path, ty, printer) :: !printers
 
@@ -139,27 +141,57 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
        it comes from. Attempt to omit the prefix if the type comes from
        a module that has been opened. *)
 
-    let tree_of_qualified lookup_fun env ty_path name =
+    let tree_of_qualified
+        out_ref out_ref_ty find_belonging_type
+        env ty_path name =
       match ty_path with
-      | Pident id ->
-          Oide_ident name
+      | Pident ty_ident ->
+          let ident_is_visible =
+            try
+              match (find_belonging_type name env).desc with
+              | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
+              | _ -> false with
+            | Not_found -> false in
+
+          if ident_is_visible then out_ref (Oide_ident name) else
+          let ty_oid = Oide_ident (Ident.name ty_ident) in
+          out_ref_ty ty_oid name
       | Pdot(p, s, pos) ->
-          if try
-               match (lookup_fun (Lident name) env).desc with
-               | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
-               | _ -> false
-             with Not_found -> false
-          then Oide_ident name
-          else Oide_dot (Printtyp.tree_of_path p, name)
+          let ident_is_visible =
+            try
+              match (find_belonging_type name env).desc with
+              | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
+              | _ -> false with
+            | Not_found -> false in
+
+          let oid =
+            if ident_is_visible
+            then Oide_ident name
+            else Oide_dot (Printtyp.tree_of_path p, name) in
+          out_ref oid
       | Papply(p1, p2) ->
-          Printtyp.tree_of_path ty_path
+          let oid = Printtyp.tree_of_path ty_path in
+          out_ref_ty oid name
 
-    let tree_of_constr =
+    let tree_of_value_constructor =
       tree_of_qualified
-        (fun lid env -> (Env.lookup_constructor lid env).cstr_res)
+        (fun oid -> Oconstr oid)
+        (fun ty_oid name -> Oconstr_ty (ty_oid, name))
+        (fun cname env ->
+          let constr =
+            Env.lookup_constructor_ref
+              (Reftypes.Pconstr (Lident cname)) env in
+          constr.cstr_res)
 
-    and tree_of_label =
-      tree_of_qualified (fun lid env -> (Env.lookup_label lid env).lbl_res)
+    and tree_of_record_label =
+      tree_of_qualified
+        (fun oid -> Olabel oid)
+        (fun ty_oid name -> Olabel_ty (ty_oid, name))
+        (fun lname env ->
+          let lbl =
+            Env.lookup_label_ref
+              (Reftypes.Plabel (Lident lname)) env in
+          lbl.lbl_res)
 
     (* An abstract type *)
 
@@ -174,117 +206,115 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
 
       let rec tree_of_val depth obj ty =
         decr printer_steps;
-        if !printer_steps < 0 || depth < 0 then Oval_ellipsis
-        else begin
-        try
-          find_printer env ty obj
-        with Not_found ->
+        if !printer_steps < 0 || depth < 0 then Oval_ellipsis else
+        begin
+        try find_printer env ty obj with
+        | Not_found ->
           match (Ctype.repr ty).desc with
           | Tvar ->
               Oval_stuff "<poly>"
-          | Tarrow(_, ty1, ty2, _) ->
+          | Tarrow(_, _ty1, _ty2, _) ->
               Oval_stuff "<fun>"
           | Ttuple(ty_list) ->
               Oval_tuple (tree_of_val_list 0 depth obj ty_list)
           | Tconstr(path, [], _) when Path.same path Predef.path_exn ->
               tree_of_exception depth obj
           | Tconstr(path, [ty_arg], _)
-            when Path.same path Predef.path_list ->
-              if O.is_block obj then
-                match check_depth depth obj ty with
-                  Some x -> x
-                | None ->
-                    let rec tree_of_conses tree_list obj =
-                      if !printer_steps < 0 || depth < 0 then
-                        Oval_ellipsis :: tree_list
-                      else if O.is_block obj then
-                        let tree =
-                          tree_of_val (depth - 1) (O.field obj 0) ty_arg in
-                        let next_obj = O.field obj 1 in
-                        tree_of_conses (tree :: tree_list) next_obj
-                      else tree_list
-                    in
-                    Oval_list (List.rev (tree_of_conses [] obj))
-              else
-                Oval_list []
+              when Path.same path Predef.path_list ->
+            if O.is_block obj then
+              match check_depth depth obj ty with
+              | Some x -> x
+              | None ->
+                  let rec tree_of_conses tree_list obj =
+                    if !printer_steps < 0 || depth < 0 then
+                      Oval_ellipsis :: tree_list
+                    else if O.is_block obj then
+                      let tree =
+                        tree_of_val (depth - 1) (O.field obj 0) ty_arg in
+                      let next_obj = O.field obj 1 in
+                      tree_of_conses (tree :: tree_list) next_obj
+                    else tree_list
+                  in
+                  Oval_list (List.rev (tree_of_conses [] obj))
+            else
+              Oval_list []
           | Tconstr(path, [ty_arg], _)
-            when Path.same path Predef.path_array ->
-              let length = O.size obj in
-              if length > 0 then
-                match check_depth depth obj ty with
-                  Some x -> x
-                | None ->
-                    let rec tree_of_items tree_list i =
-                      if !printer_steps < 0 || depth < 0 then
-                        Oval_ellipsis :: tree_list
-                      else if i < length then
-                        let tree =
-                          tree_of_val (depth - 1) (O.field obj i) ty_arg in
-                        tree_of_items (tree :: tree_list) (i + 1)
-                      else tree_list
-                    in
-                    Oval_array (List.rev (tree_of_items [] 0))
-              else
-                Oval_array []
+              when Path.same path Predef.path_array ->
+            let length = O.size obj in
+            if length > 0 then
+              match check_depth depth obj ty with
+              | Some x -> x
+              | None ->
+                  let rec tree_of_items tree_list i =
+                    if !printer_steps < 0 || depth < 0 then
+                      Oval_ellipsis :: tree_list
+                    else if i < length then
+                      let tree =
+                        tree_of_val (depth - 1) (O.field obj i) ty_arg in
+                      tree_of_items (tree :: tree_list) (i + 1)
+                    else tree_list
+                  in
+                  Oval_array (List.rev (tree_of_items [] 0))
+            else
+              Oval_array []
           | Tconstr (path, [ty_arg], _)
-            when Path.same path Predef.path_lazy_t ->
-              if Lazy.lazy_is_val (O.obj obj)
-              then let v = tree_of_val depth (Lazy.force (O.obj obj)) ty_arg in
-                   Oval_constr (Oide_ident "lazy", [v])
-              else Oval_stuff "<lazy>"
+              when Path.same path Predef.path_lazy_t ->
+            if Lazy.lazy_is_val (O.obj obj) then
+              let v = tree_of_val depth (Lazy.force (O.obj obj)) ty_arg in
+              Oval_constr (Oconstr (Oide_ident "lazy"), [v])
+            else Oval_stuff "<lazy>"
           | Tconstr(path, ty_list, _) ->
-              begin try
-                let decl = Env.find_type path env in
-                match decl with
-                | {type_kind = Type_abstract; type_manifest = None} ->
-                    Oval_stuff "<abstr>"
-                | {type_kind = Type_abstract; type_manifest = Some body} ->
-                    tree_of_val depth obj
-                      (try Ctype.apply env decl.type_params body ty_list with
-                         Ctype.Cannot_apply -> abstract_type)
-                | {type_kind = Type_variant constr_list} ->
-                    let tag =
-                      if O.is_block obj
-                      then Cstr_block(O.tag obj)
-                      else Cstr_constant(O.obj obj) in
-                    let (constr_name, constr_args) =
-                      Datarepr.find_constr_by_tag tag constr_list in
-                    let ty_args =
-                      List.map
-                        (function ty ->
-                           try Ctype.apply env decl.type_params ty ty_list with
-                             Ctype.Cannot_apply -> abstract_type)
-                        constr_args in
-                    tree_of_constr_with_args (tree_of_constr env path)
-                                           constr_name 0 depth obj ty_args
-                | {type_kind = Type_record(lbl_list, rep)} ->
-                    begin match check_depth depth obj ty with
-                      Some x -> x
-                    | None ->
-                        let rec tree_of_fields pos = function
-                          | [] -> []
-                          | (lbl_name, _, lbl_arg) :: remainder ->
-                              let ty_arg =
-                                try
-                                  Ctype.apply env decl.type_params lbl_arg
-                                    ty_list
-                                with
-                                  Ctype.Cannot_apply -> abstract_type in
-                              let lid = tree_of_label env path lbl_name in
-                              let v =
-                                tree_of_val (depth - 1) (O.field obj pos)
-                                  ty_arg
-                              in
-                              (lid, v) :: tree_of_fields (pos + 1) remainder
-                        in
-                        Oval_record (tree_of_fields 0 lbl_list)
-                    end
-              with
-                Not_found ->                (* raised by Env.find_type *)
-                  Oval_stuff "<abstr>"
-              | Datarepr.Constr_not_found -> (* raised by find_constr_by_tag *)
-                  Oval_stuff "<unknown constructor>"
-              end
+             begin try
+               let decl = Env.find_type_declaration path env in
+               match decl with
+               | {type_kind = Type_abstract; type_manifest = None} ->
+                   Oval_stuff "<abstr>"
+               | {type_kind = Type_abstract; type_manifest = Some body} ->
+                   tree_of_val depth obj
+                     (try Ctype.apply env decl.type_params body ty_list with
+                      | Ctype.Cannot_apply -> abstract_type)
+               | {type_kind = Type_variant constr_list} ->
+                 let tag =
+                   if O.is_block obj
+                   then Cstr_block(O.tag obj)
+                   else Cstr_constant(O.obj obj) in
+                 let (constr_name, constr_args) =
+                   Datarepr.find_constr_by_tag tag constr_list in
+                 let ty_args =
+                   List.map
+                     (function ty ->
+                        try Ctype.apply env decl.type_params ty ty_list with
+                        | Ctype.Cannot_apply -> abstract_type)
+                     constr_args in
+                 tree_of_value_constructor_with_args
+                   (tree_of_value_constructor env path) constr_name
+                   0 depth obj ty_args
+               | {type_kind = Type_record(fields, rep)} ->
+                  begin match check_depth depth obj ty with
+                  | Some x -> x
+                  | None ->
+                      let rec tree_of_fields pos = function
+                        | [] -> []
+                        | (lbl_name, _, lbl_arg) :: fields ->
+                          let ty_arg =
+                            try
+                              Ctype.apply env decl.type_params lbl_arg
+                                ty_list with
+                            | Ctype.Cannot_apply -> abstract_type in
+                          let tlab =
+                            tree_of_record_label env path lbl_name in
+                          let v =
+                            tree_of_val (depth - 1) (O.field obj pos)
+                              ty_arg in
+                          (tlab, v) :: tree_of_fields (pos + 1) fields in
+                      Oval_record (tree_of_fields 0 fields)
+                  end
+            with
+            | Not_found ->                (* raised by Env.find_type *)
+                Oval_stuff "<abstr>"
+            | Datarepr.Constr_not_found -> (* raised by find_constr_by_tag *)
+                Oval_stuff "<unknown constructor>"
+            end
           | Tvariant row ->
               let row = Btype.row_repr row in
               if O.is_block obj then
@@ -330,13 +360,13 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
           | ty :: ty_list ->
               let tree = tree_of_val (depth - 1) (O.field obj i) ty in
               tree :: tree_list (i + 1) ty_list in
-      tree_list start ty_list
+        tree_list start ty_list
 
-      and tree_of_constr_with_args
+      and tree_of_value_constructor_with_args
              tree_of_cstr cstr_name start depth obj ty_args =
-        let lid = tree_of_cstr cstr_name in
+        let tcstr = tree_of_cstr cstr_name in
         let args = tree_of_val_list start depth obj ty_args in
-        Oval_constr (lid, args)
+        Oval_constr (tcstr, args)
 
     and tree_of_exception depth bucket =
       let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
@@ -344,22 +374,23 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
       try
         (* Attempt to recover the constructor description for the exn
            from its name *)
-        let cstr = Env.lookup_constructor lid env in
+        let cstr = Env.lookup_constructor_ref (Reftypes.Pconstr lid) env in
         let path =
           match cstr.cstr_tag with
-            Cstr_exception p -> p | _ -> raise Not_found in
+          | 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 not (EVP.same_value (O.field bucket 0) (EVP.eval_path path))
         then raise Not_found;
-        tree_of_constr_with_args
-           (fun x -> Oide_ident x) name 1 depth bucket cstr.cstr_args
+        tree_of_value_constructor_with_args
+          (fun x -> Oconstr (Oide_ident x))
+          name 1 depth bucket cstr.cstr_args
       with Not_found | EVP.Error ->
         match check_depth depth bucket ty with
-          Some x -> x
-        | None -> outval_of_untyped_exception bucket
+        | Some x -> x
+        | None -> outval_of_untyped_exception bucket in
 
-    in tree_of_val max_depth obj ty
+    tree_of_val max_depth obj ty
 
 end
diff --git a/typing/oprint.ml b/typing/oprint.ml
index 2344436b91..7b1dbfeb25 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -19,15 +19,27 @@ exception Ellipsis
 
 let cautious f ppf arg =
   try f ppf arg with
-    Ellipsis -> fprintf ppf "..."
+  | Ellipsis -> fprintf ppf "..."
 
 let rec print_ident ppf =
   function
-    Oide_ident s -> fprintf ppf "%s" s
+  | Oide_ident s -> fprintf ppf "%s" s
   | Oide_dot (id, s) -> fprintf ppf "%a.%s" print_ident id s
   | Oide_apply (id1, id2) ->
       fprintf ppf "%a(%a)" print_ident id1 print_ident id2
 
+let print_value_constructor ppf =
+  function
+  | Oconstr id -> fprintf ppf "%a" print_ident id
+  | Oconstr_ty (id, s) -> fprintf ppf "%a.^%s" print_ident id s
+;;
+
+let print_record_label ppf =
+  function
+  | Olabel id -> fprintf ppf "%a" print_ident id
+  | Olabel_ty (id, s) -> fprintf ppf "%a.^%s" print_ident id s
+;;
+
 let value_ident ppf name =
   if List.mem name
        ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] then
@@ -51,7 +63,7 @@ let valid_float_lexeme s =
 
 let float_repres f =
   match classify_float f with
-    FP_nan -> "nan"
+  | FP_nan -> "nan"
   | FP_infinite ->
       if f < 0.0 then "neg_infinity" else "infinity"
   | _ ->
@@ -72,9 +84,10 @@ let print_out_value ppf tree =
   let rec print_tree_1 ppf =
     function
     | Oval_constr (name, [param]) ->
-        fprintf ppf "@[<1>%a@ %a@]" print_ident name print_constr_param param
+        fprintf ppf "@[<1>%a@ %a@]"
+          print_value_constructor name print_constr_param param
     | Oval_constr (name, (_ :: _ as params)) ->
-        fprintf ppf "@[<1>%a@ (%a)@]" print_ident name
+        fprintf ppf "@[<1>%a@ (%a)@]" print_value_constructor name
           (print_tree_list print_tree_1 ",") params
     | Oval_variant (name, Some param) ->
         fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param
@@ -102,28 +115,33 @@ let print_out_value ppf tree =
         fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl
     | Oval_array tl ->
         fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl
-    | Oval_constr (name, []) -> print_ident ppf name
+    | Oval_constr (name, []) -> print_value_constructor ppf name
     | Oval_variant (name, None) -> fprintf ppf "`%s" name
     | Oval_stuff s -> fprintf ppf "%s" s
-    | Oval_record fel ->
-        fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
+    | Oval_record fields ->
+        fprintf ppf "@[<1>{%a}@]"
+          (cautious (print_record_value_fields true))
+          fields
     | Oval_ellipsis -> raise Ellipsis
     | Oval_printer f -> f ppf
     | Oval_tuple tree_list ->
-        fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list
+        fprintf ppf "@[<1>(%a)@]"
+          (print_tree_list print_tree_1 ",")
+          tree_list
     | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree
-  and print_fields first ppf =
+  and print_record_value_fields first ppf =
     function
-      [] -> ()
+    | [] -> ()
     | (name, tree) :: fields ->
         if not first then fprintf ppf ";@ ";
-        fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1)
+        fprintf ppf "@[<1>%a@ =@ %a@]"
+          print_record_label name (cautious print_tree_1)
           tree;
-        print_fields false ppf fields
+        print_record_value_fields false ppf fields
   and print_tree_list print_item sep ppf tree_list =
     let rec print_list first ppf =
       function
-        [] -> ()
+      | [] -> ()
       | tree :: tree_list ->
           if not first then fprintf ppf "%s@ " sep;
           print_item ppf tree;
@@ -139,12 +157,12 @@ let out_value = ref print_out_value
 
 let rec print_list_init pr sep ppf =
   function
-    [] -> ()
+  | [] -> ()
   | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l
 
 let rec print_list pr sep ppf =
   function
-    [] -> ()
+  | [] -> ()
   | [a] -> pr ppf a
   | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l
 
@@ -184,7 +202,7 @@ and print_simple_out_type ppf =
   | Otyp_constr (id, tyl) ->
       fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
   | Otyp_object (fields, rest) ->
-      fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
+      fprintf ppf "@[<2>< %a >@]" (print_object_fields rest) fields
   | Otyp_stuff s -> fprintf ppf "%s" s
   | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
   | Otyp_variant (non_gen, row_fields, closed, tags) ->
@@ -219,7 +237,7 @@ and print_simple_out_type ppf =
         )
         n tyl;
       fprintf ppf ")@]"
-and print_fields rest ppf =
+and print_object_fields rest ppf =
   function
     [] ->
       begin match rest with
@@ -232,9 +250,10 @@ and print_fields rest ppf =
         Some _ -> fprintf ppf ";@ "
       | None -> ()
       end;
-      print_fields rest ppf []
+      print_object_fields rest ppf []
   | (s, t) :: l ->
-      fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l
+      fprintf ppf "%s : %a;@ %a" s print_out_type t
+        (print_object_fields rest) l
 and print_row_field ppf (l, opt_amp, tyl) =
   let pr_of ppf =
     if opt_amp then fprintf ppf " of@ &@ "
@@ -254,7 +273,8 @@ and print_typargs ppf =
   function
     [] -> ()
   | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1
-  | tyl -> fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl
+  | tyl -> fprintf ppf "@[<1>(%a)@]@ "
+             (print_typlist print_out_type ",") tyl
 
 let out_type = ref print_out_type
 
@@ -346,7 +366,8 @@ and print_out_sig_item ppf =
         (if vir_flag then " virtual" else "") print_out_class_params params
         name !out_class_type clt
   | Osig_exception (id, tyl) ->
-      fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl)
+      fprintf ppf "@[<2>exception %a@]"
+        print_out_constructor_definition (id, tyl)
   | Osig_modtype (name, Omty_abstract) ->
       fprintf ppf "@[<2>module type %s@]" name
   | Osig_modtype (name, mty) ->
@@ -403,18 +424,22 @@ and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) =
     | _ -> ty
   in
   let print_private ppf = function
-    Asttypes.Private -> fprintf ppf " private"
+  | Asttypes.Private -> fprintf ppf " private"
   | Asttypes.Public -> () in
   let rec print_out_tkind ppf = function
   | Otyp_abstract -> ()
-  | Otyp_record lbls ->
+  | Otyp_record fields ->
       fprintf ppf " =%a {%a@;<1 -2>}"
         print_private priv
-        (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
+        (print_list_init print_out_label_definition
+           (fun ppf -> fprintf ppf "@ "))
+        fields
   | Otyp_sum constrs ->
       fprintf ppf " =%a@;<1 2>%a"
         print_private priv
-        (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
+        (print_list print_out_constructor_definition
+           (fun ppf -> fprintf ppf "@ | "))
+        constrs
   | ty ->
       fprintf ppf " =%a@;<1 2>%a"
         print_private priv
@@ -424,13 +449,13 @@ and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) =
     print_name_args
     print_out_tkind ty
     print_constraints constraints
-and print_out_constr ppf (name, tyl) =
+and print_out_constructor_definition ppf (name, tyl) =
   match tyl with
     [] -> fprintf ppf "%s" name
   | _ ->
       fprintf ppf "@[<2>%s of@ %a@]" name
         (print_typlist print_simple_out_type " *") tyl
-and print_out_label ppf (name, mut, arg) =
+and print_out_label_definition ppf (name, mut, arg) =
   fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
     !out_type arg
 
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index 80c28ea085..a630bc1b2c 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -26,10 +26,19 @@ type out_ident =
   | Oide_dot of out_ident * string
   | Oide_ident of string
 
+type out_value_constructor =
+  | Oconstr of out_ident
+  | Oconstr_ty of out_ident * string
+
+and out_record_label =
+  | Olabel of out_ident
+  | Olabel_ty of out_ident * string
+;;
+
 type out_value =
   | Oval_array of out_value list
   | Oval_char of char
-  | Oval_constr of out_ident * out_value list
+  | Oval_constr of out_value_constructor * out_value list
   | Oval_ellipsis
   | Oval_float of float
   | Oval_int of int
@@ -38,7 +47,7 @@ type out_value =
   | Oval_nativeint of nativeint
   | Oval_list of out_value list
   | Oval_printer of (Format.formatter -> unit)
-  | Oval_record of (out_ident * out_value) list
+  | Oval_record of (out_record_label * out_value) list
   | Oval_string of string
   | Oval_stuff of string
   | Oval_tuple of out_value list
@@ -93,7 +102,8 @@ and out_sig_item =
   | Osig_type of out_type_decl * out_rec_status
   | Osig_value of string * out_type * string list
 and out_type_decl =
-  string * (string * (bool * bool)) list * out_type * Asttypes.private_flag *
+  string * (string * (bool * bool)) list * out_type *
+  Asttypes.private_flag *
   (out_type * out_type) list
 and out_rec_status =
   | Orec_not