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