From 925a6ae9f25fafc69fc47c6be50f7ec6587ac1b3 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Wed, 20 Jul 2011 14:50:45 -0400
Subject: [PATCH] Fix types of kernel struct constructors to include parent
 fields.

Merge to 5.1.2.
(cherry picked from commit 7a763a2da89a1432285c06cdf9d112d04b29c762)
---
 .../unit-tests/typecheck-tests.rkt            |  7 ++++---
 .../typed-scheme/typecheck/tc-structs.rkt     | 20 +++++++++----------
 2 files changed, 14 insertions(+), 13 deletions(-)

diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt
index 058749ba4a..e6a2167e50 100644
--- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt
+++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt
@@ -1380,9 +1380,10 @@
                     exn:break
                     arity-at-least
                     date
-                    srcloc) -Void)
-
-
+                    srcloc) 
+              -Void)
+        [tc-e (raise (exn:fail:contract "1" (current-continuation-marks))) (t:Un)]
+        [tc-err (exn:fail:contract)]
         )
   (test-suite
    "check-type tests"
diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt
index 5f62b2674e..39d7aea32c 100644
--- a/collects/typed-scheme/typecheck/tc-structs.rkt
+++ b/collects/typed-scheme/typecheck/tc-structs.rkt
@@ -289,16 +289,16 @@
      (c-> identifier? (or/c #f identifier?) (listof identifier?)
           (listof Type/c) (or/c #f identifier?) #;(listof fld?)
           any/c)
-  (let* ([parent-name (if parent (make-Name parent) #f)]
-         [parent-flds (if parent (get-parent-flds parent-name) null)])
-    (let ((defs (mk/register-sty nm flds parent-name parent-flds tys
-                     #:mutable #t)))
-      (if kernel-maker
-        (let* ((result-type (lookup-type-name nm))
-               (ty (->* tys result-type)))
-          (register-type kernel-maker ty)
-          (cons (make-def-binding kernel-maker ty) defs))
-        defs))))
+  (define parent-name (if parent (make-Name parent) #f))
+  (define parent-flds (if parent (get-parent-flds parent-name) null))
+  (define parent-tys (map fld-t parent-flds))
+  (define defs (mk/register-sty nm flds parent-name parent-flds tys #:mutable #t))
+  (if kernel-maker
+      (let* ([result-type (lookup-type-name nm)]
+             [ty (->* (append parent-tys tys) result-type)])
+        (register-type kernel-maker ty)
+        (cons (make-def-binding kernel-maker ty) defs))
+      defs))
 
 
 ;; syntax for tc/builtin-struct