diff --git a/collects/mzlib/class.ss b/collects/mzlib/class.ss index baf7705..7113357 100644 --- a/collects/mzlib/class.ss +++ b/collects/mzlib/class.ss @@ -550,10 +550,11 @@ (syntax #f) (with-syntax ([defexp (stx-car (stx-cdr idp))]) (syntax (lambda () defexp))))) - (syntax->list (syntax (idp ...))))]) + (syntax->list (syntax (idp ...))))] + [class-name class-name]) (syntax/loc e (begin - (set! id (extract-arg 'idpos init-args defval)) + (set! id (extract-arg 'class-name 'idpos init-args defval)) ...))))] [(field idp ...) (syntax/loc e (begin @@ -1403,14 +1404,15 @@ (for-class (class-name c)))))))) o)) - (define (extract-arg name arguments default) + (define (extract-arg class-name name arguments default) (if (symbol? name) ;; Normal mode (let ([a (assq name arguments)]) (cond [a (cdr a)] [default (default)] - [else (obj-error "make-object" "no argument for required init variable: ~a" name)])) + [else (obj-error "make-object" "no argument for required init variable: ~a~a" name + (if class-name (format " in class: ~a" class-name) ""))])) ;; By-position mode (cond [(< name (length arguments)) diff --git a/collects/mzlib/private/sigutil.ss b/collects/mzlib/private/sigutil.ss index 4dab29c..7d2ab3a 100644 --- a/collects/mzlib/private/sigutil.ss +++ b/collects/mzlib/private/sigutil.ss @@ -486,6 +486,7 @@ (eof-object? line)) (values lines body vars)] [(and (stx-pair? line) + (identifier? (stx-car line)) (module-identifier=? (stx-car line) dv-stx)) (syntax-case line () [(_ (id ...) expr) @@ -500,6 +501,7 @@ "improper `define-values' clause form" line)])] [(and (stx-pair? line) + (identifier? (stx-car line)) (module-identifier=? (stx-car line) begin-stx)) (let ([line-list (stx->list line)]) (unless line-list diff --git a/collects/mzlib/unitsig.ss b/collects/mzlib/unitsig.ss index c071b5e..a2eee29 100644 --- a/collects/mzlib/unitsig.ss +++ b/collects/mzlib/unitsig.ss @@ -299,8 +299,8 @@ (let ([flattened (flatten-signature #f sig)]) (with-syntax ([flattened (map (lambda (x) (datum->syntax-object (syntax signame) x #f)) flattened)]) - (syntax - (provide . flattened)))))])))) + (syntax/loc stx + (provide . flattened)))))])))) (provide define-signature let-signature