diff --git a/typing/ctype.ml b/typing/ctype.ml
index 61e6a18..1e1159f 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -4434,3 +4434,13 @@ let rec collapse_conj env visited ty =

 let collapse_conj_params env params =
   List.iter (collapse_conj env []) params
+
+let same_constr env t1 t2 =
+  let t1 = expand_head env t1 in
+  let t2 = expand_head env t2 in
+  match t1.desc, t2.desc with
+  | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2
+  | _ -> false
+
+let () =
+  Env.same_constr := same_constr
diff --git a/typing/env.ml b/typing/env.ml
index 3b991fd..e5b75cf 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -123,18 +123,18 @@ module EnvTbl =
     let empty = Ident.empty
     let nothing = fun () -> ()

-    let already_defined s tbl =
-      try ignore (Ident.find_name s tbl); true
-      with Not_found -> false
+    let already_defined wrap s tbl x =
+      try Some (wrap (fst (Ident.find_name s tbl)), wrap x)
+      with Not_found -> None

-    let add kind slot id x tbl ref_tbl =
+    let add kind slot wrap id x tbl ref_tbl =
       let slot =
         match slot with
         | None -> nothing
         | Some f ->
           (fun () ->
              let s = Ident.name id in
-             f kind s (already_defined s ref_tbl)
+             f kind s (already_defined wrap s ref_tbl x)
           )
       in
       Ident.add id (x, slot) tbl
@@ -211,6 +211,9 @@ and functor_components = {
   fcomp_subst_cache: (Path.t, module_type) Hashtbl.t
 }

+let same_constr = ref (fun _ _ _ -> assert false)
+
+
 let subst_modtype_maker (subst, mty) = Subst.modtype subst mty

 let empty = {
@@ -1388,7 +1391,7 @@ and store_value ?check slot id path decl env renv =
   check_value_name (Ident.name id) decl.val_loc;
   may (fun f -> check_usage decl.val_loc id f value_declarations) check;
   { env with
-    values = EnvTbl.add "value" slot id (path, decl) env.values renv.values;
+    values = EnvTbl.add "value" slot (fun x -> `Value x) id (path, decl) env.values renv.values;
     summary = Env_value(env.summary, id, decl) }

 and store_type ~check slot id path info env renv =
@@ -1424,16 +1427,17 @@ and store_type ~check slot id path info env renv =
     constrs =
       List.fold_right
         (fun (id, descr) constrs ->
-          EnvTbl.add "constructor" slot id descr constrs renv.constrs)
+           EnvTbl.add "constructor" slot (fun x -> `Constructor x) id descr constrs renv.constrs)
         constructors
         env.constrs;
     labels =
       List.fold_right
         (fun (id, descr) labels ->
-          EnvTbl.add "label" slot id descr labels renv.labels)
+           EnvTbl.add "label" slot (fun x -> `Label x) id descr labels renv.labels)
         labels
         env.labels;
-    types = EnvTbl.add "type" slot id (path, (info, descrs)) env.types
+    types =
+      EnvTbl.add "type" slot (fun x -> `Type x) id (path, (info, descrs)) env.types
                        renv.types;
     summary = Env_type(env.summary, id, info) }

@@ -1444,7 +1448,7 @@ and store_type_infos slot id path info env renv =
      keep track of type abbreviations (e.g. type t = float) in the
      computation of label representations. *)
   { env with
-    types = EnvTbl.add "type" slot id (path, (info,([],[]))) env.types
+    types = EnvTbl.add "type" slot (fun x -> `Type x) id (path, (info,([],[]))) env.types
                        renv.types;
     summary = Env_type(env.summary, id, info) }

@@ -1470,34 +1474,34 @@ and store_extension ~check slot id path ext env renv =
     end;
   end;
   { env with
-    constrs = EnvTbl.add "constructor" slot id
+    constrs = EnvTbl.add "constructor" slot (fun x -> `Constructor x) id
                 (Datarepr.extension_descr path ext)
                 env.constrs renv.constrs;
     summary = Env_extension(env.summary, id, ext) }

 and store_module slot id path md env renv =
   { env with
-    modules = EnvTbl.add "module" slot id (path, md) env.modules renv.modules;
+    modules = EnvTbl.add "module" slot (fun x -> `Module x) id (path, md) env.modules renv.modules;
     components =
-      EnvTbl.add "module" slot id
+      EnvTbl.add "module" slot (fun x -> `Component x) id
                  (path, components_of_module env Subst.identity path md.md_type)
                    env.components renv.components;
     summary = Env_module(env.summary, id, md) }

 and store_modtype slot id path info env renv =
   { env with
-    modtypes = EnvTbl.add "module type" slot id (path, info) env.modtypes
+    modtypes = EnvTbl.add "module type" slot (fun x -> `Module_type x) id (path, info) env.modtypes
                           renv.modtypes;
     summary = Env_modtype(env.summary, id, info) }

 and store_class slot id path desc env renv =
   { env with
-    classes = EnvTbl.add "class" slot id (path, desc) env.classes renv.classes;
+    classes = EnvTbl.add "class" slot (fun x -> `Class x) id (path, desc) env.classes renv.classes;
     summary = Env_class(env.summary, id, desc) }

 and store_cltype slot id path desc env renv =
   { env with
-    cltypes = EnvTbl.add "class type" slot id (path, desc) env.cltypes
+    cltypes = EnvTbl.add "class type" slot (fun x -> `Class_type x) id (path, desc) env.cltypes
                          renv.cltypes;
     summary = Env_cltype(env.summary, id, desc) }

@@ -1643,7 +1647,7 @@ let open_pers_signature name env =
   open_signature None (Pident(Ident.create_persistent name))
     (Lazy.force ps.ps_sig) env

-let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env =
+let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg (env : t) =
   if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost
      && (Warnings.is_active (Warnings.Unused_open "")
          || Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))
@@ -1657,7 +1661,16 @@ let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env =
       );
     let shadowed = ref [] in
     let slot kind s b =
-      if b && not (List.mem (kind, s) !shadowed) then begin
+      let really_shadow =
+        match b with
+        | Some (`Constructor c1, `Constructor c2) ->
+            not (!same_constr env c1.cstr_res c2.cstr_res)
+        | Some (`Label l1, `Label l2) ->
+            not (!same_constr env l1.lbl_res l2.lbl_res)
+        | Some _ -> true
+        | None -> false
+      in
+      if really_shadow && not (List.mem (kind, s) !shadowed) then begin
         shadowed := (kind, s) :: !shadowed;
         let w =
           match kind with
diff --git a/typing/env.mli b/typing/env.mli
index 367299a..b744924 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -231,6 +231,8 @@ val check_modtype_inclusion:
 val add_delayed_check_forward: ((unit -> unit) -> unit) ref
 (* Forward declaration to break mutual recursion with Mtype. *)
 val strengthen: (t -> module_type -> Path.t -> module_type) ref
+(* Forward declaration to break mutual recursion with Ctype. *)
+val same_constr: (t -> type_expr -> type_expr -> bool) ref

 (** Folding over all identifiers (for analysis purpose) *)