added #:unprotected-submodule

pkgs/racket-doc/scribblings/reference/contracts.scrbl

@@ -1784,8 +1784,11 @@ earlier fields.}}
 
 @defform/subs[
 #:literals (struct rename)
-(contract-out p/c-item ...)
+(contract-out unprotected-submodule contract-out-item ...)
-([p/c-item
+([unprotected-submodule
+  (code:line)
+  (code:line #:unprotected-submodule submodule-name)]
+ [contract-out-item
   (struct id/super ((id contract-expr) ...)
     struct-option)
   (rename orig-id id contract-expr)
@@ -1859,6 +1862,8 @@ Specifically, the symbol @indexed-racket['provide/contract-original-contract]
 is bound to vectors of two elements, the exported identifier and a
 syntax object for the expression that produces the contract controlling
 the export.
+
+@history[#:changed "7.3.0.3" @list{Added @racket[#:unprotected-submodule].}]
 }
 
 @defform[(recontract-out id ...)]{
@@ -1895,9 +1900,9 @@ the export.
    the private module.                              
 }
 
-@defform[(provide/contract p/c-item ...)]{
+@defform[(provide/contract unprotected-submodule contract-out-item ...)]{
 
-A legacy shorthand for @racket[(provide (contract-out p/c-item ...))],
+A legacy shorthand for @racket[(provide (contract-out unprotected-submodule contract-out-item ...))],
 except that a @racket[_contract-expr] within @racket[provide/contract]
 is evaluated at the position of the @racket[provide/contract] form
 instead of at the end of the enclosing module.}

pkgs/racket-test/tests/racket/contract/contract-out.rkt

@@ -1242,6 +1242,42 @@
                (require 'provide/contract67-a racket/contract/base)
                (provide (contract-out (struct stream ([x any/c] [y any/c]))))))))
 
+  (test/spec-passed/result
+   'provide/contract68
+   '(let ()
+      (eval '(module provide/contract68-a racket/base
+               (require racket/contract/base)
+               (provide (contract-out
+                         #:unprotected-submodule unsafe
+                         [f (-> integer? (listof integer?))]))
+               (define (f x) (list x))))
+
+      (eval '(module provide/contract68-b racket/base
+               (require (submod 'provide/contract68-a unsafe))
+               (define answer (f #f))
+               (provide answer)))
+
+      (eval '(dynamic-require ''provide/contract68-b 'answer)))
+   '(#f))
+
+  (test/spec-passed/result
+   'provide/contract69
+   '(let ()
+      (eval '(module provide/contract69-a racket/base
+               (require racket/contract/base)
+               (provide (contract-out
+                         #:unprotected-submodule no-contract
+                         (struct s ([x integer?]))))
+               (struct s (x))))
+
+      (eval '(module provide/contract69-b racket/base
+               (require (submod 'provide/contract69-a no-contract))
+               (define answer (s-x (s #f)))
+               (provide answer)))
+
+      (eval '(dynamic-require ''provide/contract69-b 'answer)))
+   '#f)
+
   (contract-error-test
    'provide/contract-struct-out
    #'(begin

racket/collects/racket/contract/private/provide.rkt

@@ -223,6 +223,8 @@
                                         pai enpfn val)))
 
 
+(define-for-syntax current-unprotected-submodule-name (make-parameter #f))
+
 ;; tl-code-for-one-id/new-name : syntax syntax syntax (union syntax #f) -> (values syntax syntax)
 ;; given the syntax for an identifier and a contract,
 ;; builds a begin expression for the entire contract and provide
@@ -261,6 +263,11 @@
                                                                     'provide/contract
                                                                     pos-module-source
                                                                     #f)
+                             #,@(let ([upe (current-unprotected-submodule-name)])
+                                  (if upe
+                                      (list #`(module+ #,upe
+                                                (provide (rename-out [#,id external-name]))))
+                                      (list)))
                              #,@(if provide?
                                     (list #`(provide (rename-out [#,id-rename external-name])))
                                     null)))
@@ -1108,7 +1115,19 @@
                                       mangle-for-maker?
                                       provide?))
 
-       (define p/c-clauses (syntax->list (syntax (p/c-ele ...))))
+       (define-values (p/c-clauses unprotected-submodule-name)
+         (syntax-case (syntax (p/c-ele ...)) ()
+           [(#:unprotected-submodule modname . more)
+            (identifier? #'modname)
+            (values (syntax->list #'more) (syntax-e #'modname))]
+           [(#:unprotected-submodule x . more)
+            (raise-syntax-error who
+                                "expected a module name to follow #:unprotected-submodule"
+                                provide-stx
+                                (if (pair? (syntax-e #'more))
+                                    (car (syntax-e #'more))
+                                    #f))]
+           [_ (values (syntax->list (syntax (p/c-ele ...))) #f)]))
        (define struct-id-mapping (make-free-identifier-mapping))
        (define (add-struct-clause-to-struct-id-mapping a parent flds/stx)
          (define flds (syntax->list flds/stx))
@@ -1141,26 +1160,26 @@
                 struct-id-mapping
                 selector-id
                 (id-for-one-id #f #f selector-id))))))
-
+       (parameterize ([current-unprotected-submodule-name unprotected-submodule-name])
-       (cond
+         (cond
-         [just-check-errors?
+           [just-check-errors?
-          (code-for-each-clause p/c-clauses)
+            (code-for-each-clause p/c-clauses)
-          (signal-dup-syntax-error)]
+            (signal-dup-syntax-error)]
-         [else
+           [else
-          (for ([clause (in-list p/c-clauses)])
+            (for ([clause (in-list p/c-clauses)])
-            (syntax-case* clause (struct) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
+              (syntax-case* clause (struct) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
-              [(struct a ((fld ctc) ...) options ...)
+                [(struct a ((fld ctc) ...) options ...)
-               (identifier? #'a)
+                 (identifier? #'a)
-               (add-struct-clause-to-struct-id-mapping #'a #f #'(fld ...))]
+                 (add-struct-clause-to-struct-id-mapping #'a #f #'(fld ...))]
-              [(struct (a b) ((fld ctc) ...) options ...)
+                [(struct (a b) ((fld ctc) ...) options ...)
-               (add-struct-clause-to-struct-id-mapping #'a #'b #'(fld ...))]
+                 (add-struct-clause-to-struct-id-mapping #'a #'b #'(fld ...))]
-              [_ (void)]))
+                [_ (void)]))
-          (with-syntax ([(bodies ...) (code-for-each-clause p/c-clauses)]
+            (with-syntax ([(bodies ...) (code-for-each-clause p/c-clauses)]
-                        [pos-module-source-id pos-module-source-id])
+                          [pos-module-source-id pos-module-source-id])
-            (syntax
+              (syntax
-             (begin
+               (begin
-               (define pos-module-source-id (quote-module-name))
+                 (define pos-module-source-id (quote-module-name))
-               bodies ...)))]))]))
+                 bodies ...)))])))]))
 
 
 (define-for-syntax (provide/contract-for-whom stx who)