diff --git a/collects/mred/mred-sig.ss b/collects/mred/mred-sig.ss index a2933039..8456ad05 100644 --- a/collects/mred/mred-sig.ss +++ b/collects/mred/mred-sig.ss @@ -105,6 +105,7 @@ list-box% list-control<%> make-eventspace + make-namespace-with-mred menu% menu-bar% menu-item% diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss index 58279d7f..e3aaeed6 100644 --- a/collects/mred/mred.ss +++ b/collects/mred/mred.ss @@ -6920,6 +6920,25 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define make-namespace-with-mred + (opt-lambda ([flag 'mred]) + (unless (memq flag '(initial mred empty)) + (raise-type-error 'make-namespace-with-mred + "flag symbol, one of 'mred, 'initial, or 'empty" + flag)) + (let ([orig (current-namespace)] + [mred-name ((current-module-name-resolver) + '(lib "mred.ss" "mred") #f #f)] + [ns (make-namespace (if (eq? flag 'empty) 'empty 'initial))]) + (parameterize ([current-namespace ns]) + (namespace-attach-module orig mred-name) + (when (eq? flag 'mred) + (namespace-require '(lib "mred.ss" "mred")) + (namespace-require '(lib "class.ss")))) + ns))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define-syntax propagate (lambda (stx) (syntax-case stx () @@ -7119,7 +7138,8 @@ text-editor-load-handler application-about-handler application-preferences-handler - current-eventspace-has-standard-menus?) + current-eventspace-has-standard-menus? + make-namespace-with-mred) ) ;; end of module