quote-module-name and quote-module-path now take an optional submodule path

(quote-module-name "..")
(quote-module-path ".." 'A 'B)

collects/syntax/location.rkt

@@ -46,21 +46,46 @@
   [quote-character-position source-location-position]
   [quote-character-span source-location-span])
 
-(define-syntax-rule (quote-module-name)
+(define-syntax-rule (module-source)
-  (module-source->module-name
+ (variable-reference->module-source
-   (variable-reference->module-source
+  (#%variable-reference)))
-    (#%variable-reference))))
 
-(define-syntax-rule (quote-module-path)
+(define-syntax (quote-module-name stx)
-  (module-source->module-path
+  (syntax-case stx ()
-   (variable-reference->module-source
+    [(_) #'(module-name-fixup (module-source) null)]
-    (#%variable-reference))))
+    [(_ "." path ...) #'(module-name-fixup (module-source) (list path ...))]
+    [(_ ".." path ...) #'(module-name-fixup (module-source) (list ".." path ...))]
+    [(_ path ...) #'(module-name-fixup null (list path ...))]))
 
-(define (module-source->module-name src)
+(define (module-name-fixup src path)
-  (or src 'top-level))
+  (or
+    (cond 
+      [(null? path) src]
+      [(list? src) (append src path)]
+      [else (append (list src) path)])
+    'top-level))
 
-(define (module-source->module-path src)
+(define-syntax (quote-module-path stx)
-  (cond
+  (syntax-case stx ()
-   [(path? src) `(file ,(path->string src))]
+    [(_) #'(module-path-fixup (module-source) null)]
-   [(symbol? src) `(quote ,src)]
+    [(_ "." path ...) #'(module-path-fixup (module-source) (list path ...))]
-   [else 'top-level]))
+    [(_ ".." path ...) #'(module-path-fixup (module-source) (list ".." path ...))]
+    [(_ path ...) #'(module-path-fixup null (list path ...))]))
+
+(define (module-path-fixup src path)
+  (define (map-path->string l)
+    (for/list ([i l])
+      (cond 
+        [(path? i) (path->bytes i)]
+        [else i])))
+  (define (last-pass src)
+    (cond
+     [(path? src) `(file ,(path->bytes src))]
+     [(symbol? src) `(quote ,src)]
+     [(list? src) (map-path->string `(submod ,@src))]
+     [else 'top-level]))
+  (last-pass
+    (cond 
+      [(null? path) src]
+      [(list? src) (append src path)]
+      [else (append (list src) path)])))

collects/syntax/scribblings/srcloc.scrbl

@@ -1,5 +1,6 @@
 #lang scribble/manual
 @(require scribble/eval
+          scribble/decode
           (for-label racket/base 
                      syntax/srcloc
                      syntax/location
@@ -291,21 +292,41 @@ the whole macro application if no @racket[form] is given.
 
 }
 
-@defform[(quote-module-name)]{
+@(define (p . l) (decode-paragraph l))
+@(define submod-note
+  (make-splice
+    (list
+      @p{Optional submod path arguments, such as @racket["."].
+         @racket[".."]. @racket['D 'E], can be supplied to reference a submodule.})))
 
-Quotes the name of the module in which the form is compiled as a path or symbol,
+@defform[(quote-module-name optional-submod-path ...)]{
-or @racket['top-level] when used outside of a module.  To produce a name
+
-suitable for use in printed messages, apply
+Quotes the name of the module in which the form is compiled as a path,
-@racket[path->relative-string/library] when the result is a path.
+symbol, submodule path, or @racket['top-level] when used outside of a
+module. @|submod-note| To produce a name suitable for use in printed messages,
+apply @racket[path->relative-string/library] when the result is a
+path.
 
 @defexamples[#:eval (new-evaluator)
 (module A racket
   (require syntax/location)
   (define-syntax-rule (name) (quote-module-name))
   (define a-name (name))
+  (define a-name1 (quote-module-name "."))
+  (module+ C
+    (require syntax/location)
+    (define c-name (quote-module-name))
+    (define c-name1 (quote-module-name "."))
+    (define c-name2 (quote-module-name ".."))
+    (provide c-name c-name1 c-name2))
   (provide (all-defined-out)))
 (require 'A)
 a-name
+a-name1
+(require (submod 'A C))
+c-name
+c-name1
+c-name2
 (module B racket
   (require syntax/location)
   (require 'A)
@@ -320,25 +341,33 @@ b-name
 
 }
 
-@defform[(quote-module-path)]{
+@defform[(quote-module-path optional-submod-path ...)]{
-
-@emph{This form is deprecated, as it does not produce module paths that reliably
-indicate collections or PLaneT packages.  Please use @racket[quote-module-name]
-and @racket[path->relative-string/library] to produce human-readable module
-names in printed messages.}
 
 Quotes the name of the module in which the form is compiled as a
 @tech[#:doc reference-path]{module path} using @racket[quote] or @racket[file],
-or produces @racket['top-level] when used outside of a module.
+@racket[submod], or produces @racket['top-level] when used outside of a module.
+@|submod-note|
 
 @defexamples[#:eval (new-evaluator)
 (module A racket
   (require syntax/location)
   (define-syntax-rule (path) (quote-module-path))
   (define a-path (path))
+  (define a-path1 (quote-module-path "."))
+  (module+ C
+    (require syntax/location)
+    (define c-path (quote-module-path))
+    (define c-path1 (quote-module-path "."))
+    (define c-path2 (quote-module-path ".."))
+    (provide c-path c-path1 c-path2))
   (provide (all-defined-out)))
 (require 'A)
 a-path
+a-path1
+(require (submod 'A C))
+c-path
+c-path1
+c-path2
 (module B racket
   (require syntax/location)
   (require 'A)
@@ -347,7 +376,7 @@ a-path
 (require 'B)
 b-path
 (quote-module-path)
-[current-pathspace (module->pathspace (quote 'A))]
+[current-namespace (module->namespace (quote 'A))]
 (quote-module-path)
 ]
 

collects/tests/syntax/location.rkt

@@ -0,0 +1,66 @@
+#lang racket/base
+(require syntax/location)
+(require tests/eli-tester)
+
+(define-syntax-rule (module-source)                                                                           
+ (variable-reference->module-source                                                                           
+  (#%variable-reference)))   
+
+(test 
+ (quote-module-name) => (module-source)                
+ (quote-module-name ".") => (module-source)                
+ (quote-module-name "..") => (list (module-source) "..")    
+ (quote-module-name ".." 'A) => (list (module-source) ".." 'A) 
+ (quote-module-name 'A 'B) => (list 'A 'B)                   
+ (quote-module-name '(file "foo.rkt") 'A) => '((file "foo.rkt") A))
+
+(module A racket
+  (require syntax/location)
+  (define-syntax-rule (name) (quote-module-name))
+  (define a-name (name))
+  (define a-name1 (quote-module-name "."))
+  (define a-path (quote-module-path))
+  (define a-path1 (quote-module-path "."))
+  (module+ C
+    (require syntax/location)
+    (define c-name (quote-module-name))
+    (define c-name1 (quote-module-name "."))
+    (define c-name2 (quote-module-name ".."))
+    (define c-path (quote-module-path))
+    (define c-path1 (quote-module-path "."))
+    (define c-path2 (quote-module-path ".."))
+    (provide c-name c-name1 c-name2 c-path c-path1 c-path2))
+  (provide (all-defined-out)))
+(module B racket
+  (require syntax/location)
+  (require (submod ".." A))
+  (define b-name (name))
+  (define b-path (quote-module-path))
+  (provide (all-defined-out)))
+(require 'B)
+
+(require 'A)
+(require (submod 'A C))
+(test
+  a-name => (list (module-source) 'A)
+  a-name1 => (list (module-source) 'A)
+  c-name => (list (module-source) 'A 'C)
+  c-name1 => (list (module-source) 'A 'C)
+  c-name2 => (list (module-source) 'A 'C "..")
+  b-name =>  (list (module-source) 'B))
+
+(test 
+ (quote-module-path) => (list 'file (path->bytes (module-source)))
+ (quote-module-path ".") => (list 'file (path->bytes (module-source)))
+ (quote-module-path "..") => (list 'submod (path->bytes (module-source)) "..")
+ (quote-module-path ".." 'A) => (list 'submod (path->bytes (module-source)) ".." 'A) 
+ (quote-module-path 'A 'B) => (list 'submod 'A 'B)                   
+ (quote-module-path '(file "foo.rkt") 'A) => '(submod (file "foo.rkt") A))
+
+(test
+  a-path => (list 'submod (path->bytes (module-source)) 'A)
+  a-path1 => (list 'submod (path->bytes (module-source)) 'A)
+  c-path => (list 'submod (path->bytes (module-source)) 'A 'C)
+  c-path1 => (list 'submod (path->bytes (module-source)) 'A 'C)
+  c-path2 => (list 'submod (path->bytes (module-source)) 'A 'C "..")
+  b-path =>  (list 'submod (path->bytes (module-source)) 'B))